(*
   Title: "COMBINATORIAL DELTA <<INFORMALISM>>";
   Version: 6.6e-34;
   Contents: Source code for a Pascal implementation (Assumed Free Pascal Compiler);
   Author(s): R. J. Cano (e-mail: "reemmmyyyyccccaaanno" at GMail dot com).
   Written on: Sunday Sept 06 2015;
   
     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation, either version 3 of the License, or
     (at your option) any later version.
  
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
  
     You should have received a copy of the GNU General Public License
     along with this program.  If not, see <http://www.gnu.org/licenses/>. 

   Purpose:
   ========

   To build expressions for a precise way of calculating products of sums in
   terms of irreducible representations by using a different alternative approach,
   instead of the "multinomial theorem".
   
   (For "multinomial theorem" as referred here, please visit
    https://en.wikipedia.org/wiki/Multinomial_theorem)

   Note: This program doesn't perform such calculations. It only generates
         specific information about the expressions to be used. However such
         functionality could be implemented for (and added by) future versions.
    
 Datatype/structure definition:
 ================== ==========

 [coef,kind,mode,indices,list]

 Coef:    Any integer; An arithmetical coefficient.

 Kind:    0="Unit";  1="Delta";   2="NO-Delta";

 Mode:    0="Total"; 1="Partial";

 Indices: Only the enabled (x-1) bits when mode is Partial,
          otherwise (when mode is Total) specifies the
          number of indices. Note for partial mode: The bits
          are 0..(x-1), and the additional bit x is always
          enabled as delimiter.

 list:    Gives the recursion for this kind of structure/datatype;


 Implemented features:

 0) Every object has always stored at least 1 object of kind zero,
    (a unit) inside its list.

*)

program Combinatorial_Delta_Informalism_Pascal;

const
  Stirling2ndKind:boolean=false;
  middleCode=0;
  OEIS=1;
  kind:array [0..2] of char=('1','@','#');
  mode:array [0..1] of char=('.',',');
 
type
  pTerm = ^term;
  Term = record
    c,
    k,
    m,
    b: Qword;
    l,
    i,
    r: pTerm;
  end;

var
  debugCounter0,
  debugCounter1:Qword;
  t,
  q0,
  q:pTerm;
  N,
  j:word;

function onePow(a,x:Qword):Qword;
var
  y:Qword;
  z:Qword;
begin
  z:=x;
  y:=1;
  while (z>0) do begin
    z:=z-1;
    y:=y*a;
  end;
  onePow:=y;
end;

function seriesPow(a,x:word):Qword;
var
  y:Qword;
  z:word;
begin
  y:=0;
  for z:=0 to x do begin
    y:=y+onePow(a,z);
  end;
  seriesPow:=y;
end;

function getAnUnit():pTerm;
var
  answer:pTerm;
begin
  (* * ) debugCounter0:=debugCounter0+1 ( * *)
  new(answer);
  with (answer^) do begin
    c:=1;
    k:=0;
    m:=0;
    b:=0;
    l:=nil;
    i:=nil;
    r:=nil;
  end;
  getAnUnit:=answer;
end;

function isJustAnUnit(thisOne:pTerm):boolean;
var
  t : pTerm;
  answer : boolean;
begin
  answer:=false;
  t:= thisOne;
  if (t <> nil ) then answer:= (
      (t^.c=  1)
  and (t^.k=  0)
  and (t^.m=  0)
  and (t^.b=  0)    
  and (t^.l=nil)
  and (t^.i=nil)
  and (t^.r=nil)
  );
  isJustAnUnit:= answer;
end;

function getThisTerm(cc,kk,mm,bb:Qword;ll,ii,rr:pTerm):pTerm;
var
  answer:pTerm;
begin
  (* * ) debugCounter0:=debugCounter0+1 ( * *)
  new(answer);
  with (answer^) do begin
    c:=cc;
    k:=kk;
    m:=mm;
    b:=bb;
    l:=ll;
    i:=ii;
    r:=rr;
  end;
  getThisTerm:=answer;
end;

procedure prettyPrint(this:pTerm; format:byte);
var
  t0,
  t:pTerm;
  j,
  k,
  s:Qword;
begin
  case format of
    middleCode:
      begin
        t0:=this;
        while (t0<>nil) do begin
          write(kind[t0^.k]+mode[t0^.m],t0^.b,'(');
          t:=t0^.i;
          while (t <> nil) do begin
            write(t^.c,'*',kind[t^.k]+mode[t^.m],t^.b);
            t:=t^.r;
            if(t <> nil) then write('+');
          end;
          write(')');
          t0:=t0^.r;
          if(t0 <> nil) then write('+') else writeln(';');
        end;
      end;
    OEIS:
      begin
        if (NOT Stirling2ndKind) then begin
          t0:=this;
          while (t0 <> nil) do begin
            if (t0^.k=1) then write('\delta_{');
            if (t0^.k=2) then write('\cancel{\delta}_{');
            if (t0^.m=0) then begin
              j:=1;
              while (j <= t0^.b) do begin
                write(j);
                j:=j+1;
              end;
            end;
            write('}');
            if (NOT isJustAnUnit(t0^.i)) then begin
              t:=t0^.i;
              write('\left(');
              while (t <> nil) do begin
                if (t^.c>1) then write(t^.c);
                if (t^.k=1) then write('\delta_{');
                if (t^.k=2) then write('\cancel{\delta}_{');
                j:=0;
                while (seriesPow(2,j) < t^.b) do j:=j+1;
                k:=0;
                while (k <= j) do begin
                  if (onePow(2,k) and t^.b > 0) then write(k+1);
                  k:= k+1;
                end;
                write('}');           
                t:=t^.r;
                if (t <> nil) then write('+');
              end;
              write('\right)');
            end;
            t0:=t0^.r;
            if (t0 <> nil) then write('+');
          end;
        end else begin
          t0:=this;
          while (t0 <> nil) do begin
            s:=0;
            t:=t0^.i;
            while (t <> nil) do begin
              s:=s+t^.c;
              t:=t^.r;
            end;
            write(s,',');
            t0:=t0^.r;
          end;
        end;
      end;
    else
     begin
     end;
  end;
end;

procedure listPut(var toThisList, newInput: pTerm);
var
  t:pTerm;
begin
  if (toThisList = nil) then begin
    toThisList:=newInput;
    toThisList^.l:=nil;
    toThisList^.r:=nil;
  end else begin
    t:=toThisList;
    while (t^.r <> nil) do t:=t^.r;
    t^.r:=newInput;
    newInput^.l:=t;
    newInput^.r:=nil;
  end
end;

function clone(what:pTerm):pTerm;
var
  answer_part1,
  answer_part2,
  t,
  z:pTerm;
begin
  (* * ) debugCounter0:=debugCounter0+1 ( * *)
  new(answer_part1);
  answer_part1^.c:=what^.c;
  answer_part1^.k:=what^.k;
  answer_part1^.m:=what^.m;
  answer_part1^.b:=what^.b;
  answer_part1^.l:=nil;
  answer_part1^.i:=nil;
  if (what^.i <> nil) then begin
    answer_part2:=nil;
    t:=what^.i;
    while (t <> nil) do begin
      z:=clone(t);
      listPut(answer_part2,z);
      t:=t^.r;
    end;
    answer_part1^.i:=answer_part2;
  end;
  answer_part1^.r:=nil;
  clone:=answer_part1;
end;

procedure discard(var data:pTerm);
var
  t0,
  t:pTerm;
begin
  if (data <> nil) then begin
    while(data^.l <> nil) do data:=data^.l;
    while(data <> nil) do begin
      t:=data^.i;
      data^.i:=nil;
      if (t <> nil) then begin
        while(t^.l <> nil) do t:=t^.l;
        while (t <> nil) do begin
          t0:=t;
          t:=t^.r;
          if (t <> nil) then t^.l:=nil;
          (* * ) debugCounter1:=debugCounter1+1; ( * *)
          dispose(t0);
        end;
      end;
      t:=nil;
      t0:=data;
      data:=data^.r;
      if (data <> nil) then data^.l:=nil;
      (* * ) debugCounter1:=debugCounter1+1; ( * *)
      dispose(t0);
    end;
  end;
end;

procedure simplify(var Operand:pTerm);
var
  c:Qword;
  L,
  R,
  x,
  y,
  t,
  u,
  w,
  q:pTerm;
begin
  c:=0;
  if (Operand <> nil) then begin
    c:=c+1;
    R:=Operand;
    while (R <> nil) do begin
      R:=R^.r;
      c:=c+1;
    end;
    if (c>3) then begin
      L:=Operand^.r;
      while (L^.r <> nil) do begin
        R:=L^.r;
        if ( (L^.c = R^.c) and (L^.k = R^.k) and (L^.m = R^.m) ) then begin
          x:=L^.i;
          y:=R^.i;
          L^.i:=nil;
          R^.i:=nil;
          t:=L^.l;
          t^.r:=R;
          R^.l:=t;
          (* * ) debugCounter1:=debugCounter1+1; ( * *)
          dispose(L);
          t:=x;
          while (t^.r <> nil) do t:=t^.r;
          t^.r:=y;
          y^.l:=t;
          q:=x;
          x:=nil;
          u:=q;
          while (u <> nil) do begin
            if (u^.r <> nil) then begin
              w:=u^.r;
              while (w <> nil) do begin
                if ( (w^.k=u^.k) and (w^.m=u^.m) and (w^.b=u^.b) ) then begin
                  w^.c:= w^.c + u^.c;
                  u^.c:= 0;
                end;
                w:=w^.r;
              end;
            end;
            u:=u^.r;
          end;
          u:=q;
          while (u <> nil) do begin
            if (u^.c > 0) then begin
              w:=clone(u);
              listPut(x,w);
            end;
            u:=u^.r;
          end;
          u:=nil;
          w:=nil;
          discard(q);
          R^.i:=x;
          L:=R;
        end;
        L:=L^.r;
      end;
    end;
  end;
end;

procedure fixIndices(var forThem:pTerm; toThis:Qword);
var
  p,
  s:pTerm;
  c,
  k1,
  k2:Qword;
begin
  p:=forThem;
  while (p <> nil) do begin
    if (p^.b and onePow(2,toThis-1) > 0) then begin
      if ( (p^.k=2) and (p^.m=1) ) then begin
        c:=p^.b;
        c:=c-onePow(2,toThis-1);
        k2:=0;
        k1:=0;
        while (k1<=toThis-1) do begin
          if (onePow(2,k1) and c > 0) then k2:=k2 + 1;
          k1:=k1 + 1;
        end;
        p^.b:= k2;
        p^.m:= 0;
        s:=p^.i;
        while (s<>nil) do begin
          if (s^.b and onePow(2,k2-1) > 0) then begin
            s^.b:= s^.b - onePow(2,k2-1) + onePow(2,toThis-1);
          end;
          s:=s^.r;
        end;
      end;
    end;
    p:=p^.r;
  end;
end;

function SymbolicProduct(var A, B : pTerm):pTerm;
var
  answer, x, y, t :pTerm;
begin
  if ( (A <> nil) and (B <> nil) ) then begin
    answer:=nil;
    if ( isJustAnUnit(A) ) then begin
      x:=B;
      while (x <> nil) do begin
        t:=clone(x);
        listPut(answer,t);
        x:=x^.r;
      end;
    end
    else if ( isJustAnUnit(B) ) then begin
      y:=A;
      while (y <> nil) do begin
        t:=clone(y);
        listPut(answer,t);
        y:=y^.r;
      end;
    end
    else begin
      x:=A;
      while (x <> nil) do begin
        y:=B;
        while (y <> nil) do begin
          t:=getThisTerm((x^.c)*(y^.c),x^.k,x^.m,(x^.b) OR (y^.b),nil,nil,nil);
          listPut(answer,t);
          y:=y^.r;
        end;
        x:=x^.r;
      end;    
    end;
  end  
  else begin
    answer:=getAnUnit();
    answer^.c:=0;
  end;
  SymbolicProduct:= answer;
end;

procedure parse(var myInput, myOutput: pTerm);
var
  p,s,y,z,w:pTerm;
  bb:Qword;
   j:integer;
begin
  p:=myInput;
  if (p <> nil) then begin
    myOutput:=nil;
    while(p <> nil) do begin
      if (p^.k=0) then begin
      end;
      if (p^.k=1) then begin
        if (p^.m=0) then begin
          bb:=p^.b+1;
          s:=getThisTerm(1,1,0,bb,nil,getAnUnit(),nil);
          listPut(myOutput,s);
          if (bb > 2) then begin
            s:=getThisTerm(1,2,0,2,nil,getThisTerm(1,1,1,seriesPow(2,bb-1)-onePow(2,1),nil,nil,nil),nil);
          end else begin
            s:=getThisTerm(1,2,0,2,nil,getAnUnit(),nil);
          end;
          listPut(myOutput,s);
        end
      end;
      if (p^.k=2) then begin (* Warning: "bb" is assumed to be already set, after processing firstly a "@." term. *)
        if (p^.m=0) then begin
          s:=clone(p);
          j:=1;
          z:=nil;
          while (j<=s^.b) do begin
            w:=getThisTerm(1,1,1,onePow(2,j-1)+onePow(2,bb-1),nil,nil,nil);
            listput(z,w);          
            j:=j+1;
          end;
          w:=s^.i;
          s^.i:=nil;
          y:=SymbolicProduct(w,z);
          discard(w);
          discard(z);
          s^.i:=y;
          listPut(myOutput,s);
          if (p^.r <> nil) then begin
            s:=clone(p);
            s^.m:=1;
            s^.b:=seriesPow(2,s^.b-1)+onePow(2,bb-1);
          end else begin
            s:=getThisTerm(1,2,0,bb,nil,getAnUnit(),nil);
          end;
          listPut(myOutput,s);
        end;
        if (p^.m=1) then begin
        end;
      end;
      p:=p^.r;
    end;
    fixIndices(myOutput,bb);
    simplify(myOutput);
  end;
end;

BEGIN
  repeat begin
    write('Please specify the exponent or row: (N>1) ');
    readln(N);
  end until (N>1);  
  q0:=getThisTerm(1,1,0,1,nil,getAnUnit(),nil);
  (*
  writeln('Initial condition:');
  prettyPrint(q0,middleCode);
  *)
  (* * ) writeln('Applying the algorithm...'); ( * *)
  (* *) if (Stirling2ndKind) then write('1,'); (* *)
  for j:=1 to (N-1) do begin
    t:=q0;
    parse(q0,q);
    (* * ) prettyPrint(q,middleCode); ( * *) (* *) if (Stirling2ndKind) then prettyPrint(q,OEIS); (* *)
    q0:=q;
    discard(t);
  end;
  (* * ) writeln('Result:'); ( * *)
  (* * ) prettyPrint(q,middleCode); ( * *) (* *) if (NOT Stirling2ndKind) then prettyPrint(q,OEIS); (* *)
  discard(q);
  (* * )
  writeln('Debug counters diff: ',debugCounter0-debugCounter1,';');
  ( * *)
  writeln('');

(*  
   Final   note(s):
  ======= =========
  
  By using the present version of this code, and for the same N, the result shown after its execution
  is identical to the following PARI-GP definition:
  
  v(n)={my(a=vector(n*(n+1)/2),b);for(j=1,n,b=j*(j-1)/2;for(k=1,j,a[b+k]=stirling(j,k,2))); a}

  This fact demonstrates that the algorithms and the proposed formalism are correct, and more yet,
  correctly implemented.
  
  Extra functionality was added: By turning the "Stirling2ndKind" flag to "false", this program will
  generate AMSMATH/AMSSYMB LaTEX source, for the summation expressions studied here.
  
   Limitation:
  =============
  
  Due the fixed size in bits of every data type implemented by this environment (Qwords = 64 Bits),
  naturally this program will fail from some N onwards. Unless you replace "Qword" with a bigger integer
  type supported by the compiler, reliable results will be obtained with this version up to N=26;
  
*)

END.